-- |
-- Module:        Hexena.Text.Hexdump
-- Stability:     Experimental
-- Portability:   Portable
--
-- This contains the module for exporting and importing ByteStrings as
-- hexdumps. A simple description of the file format is:
--
--  1. Position in the file
--  2. a colon and a space
--  3. hex values separated by a space
--  4. two spaces end the hex values and everything thereafter is ignored
--
-- Another variant is where number four (two spaces) is replaced by a
-- 'tab' character and everything (ok, only ascii characters $20 to
-- $7e) until the end-of-line (line feed character $0a) is taken
-- literally into the bytestring.


module Hexena.Text.Hexdump 
               ( compactHexify
               , hexifyLines
               , hexdumpBS
               , hexDump
               , hexDumpLine
               , hexRestoreLine
               , hexRestoreLines
               , safeHexifyLines
               ) where

import qualified Data.ByteString.Lazy.Char8 as L8
import qualified Data.ByteString.Lazy as BL
import Control.Arrow (second)
import Data.Maybe (fromJust, isNothing)
import Data.Char (chr, ord)
import Data.Int
import Data.List (find, findIndex, isPrefixOf, sortBy, tails, unfoldr)
import Data.Ord (comparing)
import Text.Printf


hexdumpBS :: BL.ByteString -> String
hexdumpBS bs = let octets = BL.unpack bs
                   fun x | x >= 0x20 && x < 0x7f = x
                         | otherwise = 0x2e
                   pf = printf "%02x"
                   hd = unwords $ map pf octets
                   asString = map (chr . fromIntegral . fun) octets
            in hd ++ "  " ++ asString

hexDumpLine :: Int64 -> Int -> BL.ByteString -> String
hexDumpLine pos w s | pos >= BL.length s = []
                    | otherwise = tpos ++ hexdumpBS s''
  where tpos = printf "%08X: " pos :: String
        s' = BL.drop pos s
        s'' = BL.take (fromIntegral w) s'

hexDump :: Int -> BL.ByteString -> [String]
hexDump w s = let w' = fromIntegral w
                  poss = [0,w'..BL.length s]
                  func x = hexDumpLine x w s
              in map func poss

hexRestoreLine :: String -> (Int64, BL.ByteString)
hexRestoreLine s = let dSpPos = findIndex (isPrefixOf "  ") $ tails s
                       (offset', dump) = second tail $ span (':' /=) s
                       offset :: Int64
                       offset = read ("0x" ++ offset')
                       ascPart = find (\(_,x) -> isPrefixOf "  " x || isPrefixOf "\t" x) $ zip [0..] $ tails dump
                       hexPart' Nothing = dump
                       hexPart' (Just h) = take (fst h) dump
                       hexPart = hexPart' ascPart
                       litPart = if isNothing ascPart then [] else lit2Hex $ snd $ fromJust ascPart
                       lit2Hex x | head x == ' ' = []
                                 | head x == '\t' = map (fromIntegral . ord) $ tail x
                                 | otherwise = error "impossible condition in hexdump"
                       hexWords = map (read . ("0x" ++)) $ words hexPart
                   in ( offset
                      , BL.pack (hexWords ++ litPart)
                      )

-- | Restore a hexdump from multiple strings, each representing a
-- single line. Currently the implementation is not very fast as
-- concatenating bytestrings is explensive.
-- 
-- TODO: Optimise this.
hexRestoreLines :: [String] -> BL.ByteString
hexRestoreLines xs = let posStr = sortBy (comparing fst) $ map hexRestoreLine xs
                     in foldl (\r (p, s) -> BL.concat [r, BL.replicate (p - (BL.length r)) 0, s]) BL.empty posStr

-- | Hexify a number of Bytes from a Bytestring.
hexByteString :: Int -> L8.ByteString -> String
hexByteString n = unwords . map (printf "%02x") . L8.unpack . L8.take (fromIntegral n)

hexLine :: (Char -> Char) -> L8.ByteString -> String
hexLine mF s | L8.null s = []
             | otherwise = printf "%-24s %-24s %s" (h s) (h s') $ map mF $ L8.unpack $ L8.take 16 s
  where s' = L8.drop 8 s
        h = hexByteString 8

hexifyLine :: L8.ByteString -> String
hexifyLine s | L8.null s = []
             | otherwise = printf "%-24s %-24s %s" (h s) (h s') $ take 16 $ L8.unpack s
  where s' = L8.drop 8 s
        h = hexByteString 8

hexifyLines :: Int64 -> L8.ByteString -> [String]
hexifyLines pos s | pos >= L8.length s = []
                  | otherwise = (tpos ++ hexifyLine s') : hexifyLines (pos + 16) s
  where tpos = printf "%08X: " pos :: String
        s' = L8.drop pos s

safeHexifyLines :: Int64 -> L8.ByteString -> [String]
safeHexifyLines pos s | pos >= L8.length s = []
                      | otherwise = (tpos ++ hL s') : safeHexifyLines (pos + 16) s
    where hL = hexLine f 
          tpos = printf "%08X: " pos
          s' = L8.drop pos s
          f x | x >= ' ' && x <= '~' = x
              | otherwise = '.'

-- hexifyList :: [a] -> [String]
-- hexifyList = map (printf "%02x")

compactHexify :: L8.ByteString -> [String]
compactHexify bs = zipWith (++) pos $ bSplit 16 bs'
    where bSplit i = unfoldr (\x -> if null x then Nothing else Just $ bsF $ splitAt i x)
          bsF (x, y) = (unwords x, y)
          bs' :: [String]
          bs' = map (printf "%02x") $ L8.unpack bs
          pos = map (printf "%06X: ") ([0,16..] :: [Int])
